(in-package #:srfi.setagaya)

(export '(xcons cons* list-tabulate list-copy circular-list iota
	  pair? null? proper-list? circular-list? dotted-list?
	  not-pair? null-list? list=
	  
	  car+cdr take drop take-right drop-right
	  ;; take! drop-right!
	  split-at   
	  ;; split-at!				
	  srfi-last last-pair
	  
	  length+
	  zip unzip1 unzip2 unzip3 unzip4 unzip5
	  
	  for-each fold unfold pair-fold srfi-reduce
	  fold-right unfold-right pair-fold-right reduce-right
	  append-map append-map!
	  map! pair-for-each filter-map map-in-order
	  
	  filter  partition  
	  
	  memq memv find find-tail
	  list-index take-while drop-while
	  span srfi-break 
	  
	  assq assv alist-cons
	  
	  lset<= lset= lset-adjoin lset-union
	  lset-intersection lset-difference
	  lset-xor lset-diff+intersection
	  ))

;; =============================================================================
;; 構築子
;; =============================================================================

;; cons

;; list

(defun xcons (cd ca)
  (cons ca cd))

(defun cons* (&rest elts)
  (cond ((cdr elts)
	 (prog (init l retlst)
	       (setq init (reverse elts))
	       (setq l (cddr init))
	       (setq retlst (cons (cadr init) (car init)))
	     l (cond ((endp l) (return retlst)))
	       (setq retlst (cons (car l) retlst))
	       (setq l (cdr l))
	       (go l)))
	('t (car elts))))

;; make-list

(defun list-tabulate (n init-proc)
  (prog (l retlst)
        (setq l (iota n))
      l (cond ((endp l) (return (nreverse retlst))))
	(setq retlst (cons (funcall init-proc (car l)) retlst))
	(setq l (cdr l))
	(go l)))

(defun list-copy (list)
  (copy-list list))

(defun circular-list (&rest elts)
  (cdr (rplacd (last elts) elts)))

(defun iota (count &optional (start 0) (step 1))
  (prog (i c retlst)
        (setq i start)
	(setq c count)
	(setq retlst '() )
      l (cond ((zerop c) (return (nreverse retlst))))
	(setq retlst (cons i retlst))
	(setq c (1- c))
	(setq i (+ step i))
	(go l)))

;; =============================================================================
;; 述語
;; =============================================================================
;;    pair? null?
;;    proper-list? circular-list? dotted-list?
;;    not-pair? null-list?
;;    list=

(defun pair? (x)
  (consp x))

(defun null? (x)
  (null x))

(defun proper-list? (x)
  (and (listp x)
       (not (circular-list? x))
       (null (cdr (last x)))))

(defun circular-list? (lst)
  (and (consp lst)
       (not (atom (cdr lst)))
       (cddr lst)
       (prog (x y)
             (setq x (cdr lst))
	     (setq y (cddr lst))
          l  (cond ((null x) (return nil))
		   ((eq x y) (return t)))
	     (setq x (cdr x))
	     (setq y (cddr y))
	     (go l))))

(defun dotted-list? (x)
  (and (listp x)
       (not (circular-list? x))
       (not (null (cdr (last x))))))

(defun null-list? (lst)
  (cond ((not (listp lst))
       (error "argument must be a list, But got ~S"  lst))
      ((null lst) t)
      ('t nil)))

(defun not-pair? (x)
  (not (consp x)))

(defun list= (elt= &rest lists)
  (prog (l item)
      (setq l lists)
   l  (cond ((every #'null l) (return t)))
      (setq item (mapcar #'car l))
   l2 (cond ((null (cdr item)))
      ('t (or (funcall elt= (car item) (cadr  item)) (return nil))
          (setq item (cdr item))
          (go l2)))
      (setq l (mapcar #'cdr l))
      (go l)))

;; =============================================================================
;; 選択子
;; =============================================================================
;;    car cdr ... cddadr cddddr list-ref
;;    first second third fourth fifth sixth seventh eighth ninth tenth
;;     car+cdr
;;     take       drop
;;     take-right drop-right
;;     take!      drop-right!
;;     split-at   split-at!
;;    last last-pair

;; car cdr ... cddadr cddddr

(defun list-ref (clist i)
  (scheme-car (nthcdr i clist)))

;; first
;; second
;; third
;; fourth
;; fifth
;; sixth
;; seventh
;; eighth
;; ninth
;; tenth

(defun car+cdr (list)
  (values (car list) (cdr list)))

(defun take (x i)
  (cond ((< (length x) i) (error "foo!")))
  (prog (l r cnt)
        (setq l x)
	(setq r () )
	(setq cnt i)
    l   (cond ((zerop cnt) (return (nreverse r))))
        (push (car l) r)
	(setq l (cdr l))
	(setq cnt (1- cnt))
	(go l)))

(defun drop (x i)
  (prog (l cnt)
        (setq l x)
        (setq cnt i)
     l  (cond ((zerop cnt) (return l)))
	(setq l (cdr l))
	(setq cnt (1- cnt))
	(go l)))

;; helper take-right 
(defun count-elts (flist)
  (do ((l flist (cdr l))
       (cnt 0 (1+ cnt)))
      ((atom l) (return (1+ cnt)))))

(defun take-right (flist index)
  (cond ((>= index (count-elts flist)) 
	 (error "*** ERROR: argument out of range: ~A" index)))
  (prog (cnt lim)
        (setq cnt 0)
	(setq lim (- (count-elts flist) index 1))
    l	(cond ((= cnt lim) (return flist)))
	(setq flist (cdr flist))
	(incf cnt)
	(go l)))

(defun drop-right (flist index)
  (cond ((>= index (count-elts flist)) 
	 (error "*** ERROR: argument out of range: ~A" index)))
  (prog (cnt lim r)
        (setq cnt 0)
	(setq lim (- (count-elts flist) index 1))
    l	(cond ((= cnt lim) (return (nreverse r))))
        (push (pop flist) r)
	(incf cnt)
        (go l)))

;;#     take!      drop-right!

(defun split-at (x i)
  (values (take x i)
	  (drop x i)))

;;# split-at!

(defun srfi-last (pair)
  (car (last pair)))

(defun last-pair (pair)
  (last pair))

;; =============================================================================
;; その他
;; =============================================================================
;;     length length+
;;     append  concatenate  reverse
;;     append! concatenate! reverse!
;;     append-reverse append-reverse!
;;     zip unzip1 unzip2 unzip3 unzip4 unzip5
;;     count

(defun length+ (list)
  (and (proper-list? list)
       (list-length list)))

;;     append  concatenate  reverse
;;     append! concatenate! reverse!
;;#     append-reverse append-reverse!

;; helper
(defun scheme-car (list)
  (cond ((consp list) (car list))
	('T (error "*** ERROR: pair required, but got ~S" list))))

;; helper unzip*
(defun unzip* (lists i)
  (prog (l r cnt)
        (setq l lists)
	(setq cnt i)
    l	(cond ((zerop cnt) (return (apply #'values (nreverse r)))))
	(push (mapcar #'scheme-car l) r)
	(setq l (mapcar #'cdr l))
	(decf cnt)
	(go l)))

(defun zip (&rest lists)
  (apply #'map 'list #'list lists))

(defun unzip1 (lists)
  (unzip* lists 1))

(defun unzip2 (lists)
  (unzip* lists 2))

(defun unzip3 (lists)
  (unzip* lists 3))

(defun unzip4 (lists)
  (unzip* lists 4))

(defun unzip5 (lists)
  (unzip* lists 5))

;; count

;; =============================================================================
;; 畳み込み、逆畳み込み、マップ		
;; =============================================================================
;;     map for-each
;;     fold       unfold       pair-fold       reduce
;;     fold-right unfold-right pair-fold-right reduce-right
;;     append-map append-map!
;;     map! pair-for-each filter-map map-in-order


;;     map

(defun for-each (f &rest clists)
  (apply #'mapc f clists))

(defun fold (kons knil &rest clists)
  (prog (r)
        (setq r knil)
    l   (cond ((some #'endp clists) (return r)))
	(setq r (apply kons `(,@(mapcar #'car clists) ,r)))
	(setq clists (mapcar #'cdr clists))
	(go l)))

(defun unfold (p f g seed &optional (tail-gen #'(lambda (x) (declare (ignore x)) '())))
  (do ((seed seed (funcall g seed))
       (result '() (cons (funcall f seed) result)))
      ((funcall p seed) (nreconc result (funcall tail-gen seed)))))

(defun pair-fold (kons knil &rest clists)
  (do ((ls clists (mapcar #'cdr ls))
       (r knil (apply kons `(,@ls ,r))))
      ((some #'endp ls) r)))

(defun srfi-reduce (kons knil clist)
  (fold kons knil clist))

(defun fold-right (kons knil &rest clists)
  (prog (r pairs)
        (setq r knil)
    a   (cond ((some #'endp clists) (go b)))
        (push (mapcar #'car clists) pairs)
        (setq clists (mapcar #'cdr clists))
        (go a)
    b   (cond ((endp pairs) (return r)))
        (setq r (apply kons `(,@(car pairs) ,r)))
        (pop pairs)
        (go b)))

(defun unfold-right (p f g seed &optional tail)
  (prog nil
    L   (cond ((funcall p seed) (return tail)))
    	(setq tail (cons (funcall f seed) tail))
	(setq seed (funcall g seed))
	(go L)))

(defun pair-fold-right (kons knil &rest clists)
  (prog (r pairs)
        (setq r knil)
    a   (cond ((some #'endp clists))
	      ('T (push clists pairs)
		  (setq clists (mapcar #'cdr clists))
		  (go a)))
    b   (cond ((endp pairs) (return r)))
        (setq r (apply kons `(,@(car pairs) ,r)))
        (pop pairs)
        (go b)))

(defun reduce-right (kons knil clist)
  (fold-right kons knil clist))

(defun append-map (f &rest clists)
  (apply #'append (apply #'mapcar f clists)))

(defun append-map! (f &rest clists)
  (apply #'mapcan f clists))

(defun map! (f &rest clists)
  (do ((l clists (mapcar #'cdr l))
       (result '() (cons (apply f (mapcar #'car l)) result)))
      ((some #'null l) (nreverse result))))

(defun pair-for-each (f &rest clists)
  (apply #'mapl f clists))

;; macro!
(defmacro filter-map (f &body clists)
  `(reduce #'(lambda (retlst x)
	       (let ((it (funcall ,f x)))
		 (if it
		     `(,@retlst ,it)
		     retlst)))
	   ,@clists
	   :initial-value '() ))

(defun map-in-order (f &rest clists)
  (apply #'map 'list f clists))


;; =============================================================================
;; フィルタ、分割
;; =============================================================================
;;     filter  partition  remove
;;     filter! partition! remove!

(defun filter (pred list)
  (remove-if-not pred list))

(defun partition (pred list)
  (prog (l pos neg item)
        (setq l list)
    l	(cond ((endp l) (return (values (nreverse pos) (nreverse neg)))))
        (setq item (pop l))
        (if (funcall pred item)
	    (push item pos)
	    (push item neg))
	(go l)))

;; remove
;; filter! partition! remove!

;; =============================================================================
;; 検索
;; =============================================================================
;;     member memq memv
;;     find find-tail
;;     any every
;;     list-index
;;     take-while drop-while take-while!
;;     span break span! break!

;; member

;; memq
(defun memq (x y)
  (prog ()
    l   (cond ((endp y) () )
	      ((eq x (car y)) (return y)))
	(pop y)
	(go l)))

;; memv
;			;member + (eq)v/eql
(defun memv (x y)
  (member x y :test #'eql))
;; 



;; find
(defun srfi-find (pred clist)
  (find-if pred clist))

;; find-tail
(defun find-tail (pred clist)
  (prog nil
        (mapl #'(lambda (x)
		  (and (funcall pred (car x)) (return x)))
	      clist)))

;; any
;; every

;; list-index
(defun list-index (pred &rest clists)
  (prog (idx)
        (setq idx 0)
    l	(cond ((loop for xx in clists thereis (null xx)) (return nil))
	      ((apply pred (mapcar #'car clists)) (return idx)))
	(setq idx (1+ idx))
	(setq clists (mapcar #'cdr clists))
	(go l)))

;; take-while
(defun take-while (pred clist)
  (prog (l res)
        (setq l clist)
    l	(cond ((endp l) (go xit)))
	(if (funcall pred (car l))
	    (push (pop l) res)
	    (go xit))
	(go l)
    xit	(return (nreverse res))))

;; drop-while
(defun drop-while (pred clist)
  (prog (l)
        (setq l clist)
    l	(cond ((endp l) (return l)))
	(or (funcall pred (car l))
	    (return l))
	(pop l)
	(go l)))

;; take-while!

;; span
(defun span (pred clist)
  (prog (l res)
        (setq l clist)
    l	(cond ((endp l) (go xit)))
	(if (funcall pred (car l))
	    (push (car l) res)
	    (go xit))
	(pop l)
	(go l)
    xit	(return (values (nreverse res) l))))

;; break
;(shadow 'break)

(defun srfi-break (pred clist)
  (prog (l res)
        (setq l clist)
    l	(cond ((endp l) (go xit)))
	(if (funcall (complement pred) (car l))
	    (push (car l) res)
	    (go xit))
	(pop l)
	(go l)
    xit	(return (values (nreverse res) l))))

;; span!
;; break!

;; =============================================================================
;; 削除
;; =============================================================================
;;     delete  delete-duplicates
;;     delete! delete-duplicates!

;; =============================================================================
;; 連想リスト
;; =============================================================================
;;     assoc assq assv
;;     alist-cons alist-copy
;;     alist-delete alist-delete!

;; assoc

;; assq
(defun assq (key alist)
  (assoc key alist :test #'eq))

;; assv
(defun assv (key alist)
  (assoc key alist :test #'eql))

;; alist-cons
(defun alist-cons (key datum alist)
  (cons (cons key datum) alist))

;; alist-copy
;; alist-delete
;; alist-delete!

;; =============================================================================
;; リストの集合演算
;; =============================================================================
;;     lset<= lset= lset-adjoin
;;     lset-union      lset-union!
;;     lset-intersection    lset-intersection!
;;     lset-difference            lset-difference!
;;     lset-xor      lset-xor!
;;     lset-diff+intersection          lset-diff+intersection!

;; lset<=
(defun lset<= (elt= &rest lists)
  (do ((x (car lists))
       (l (cdr lists) (cdr l)))
      ((endp l) t)
    (do ((y x (cdr y)))
        ((endp y))
      (or (member (car y) (car l) :test elt=)
          (return-from lset<= nil)))))

;; lset=
(defun lset= (elt= &rest lists)
  (prog (l x y yy)
        (setq x (car lists))
        (setq l (cdr lists))
    a   (cond ((endp l) (return t)))
        (setq y (car l))
        (setq yy x)
    b   (cond ((endp y) (go c)))
        (or (member (car y) x :test elt=)
            (return nil))
        (pop y)
        (go b)
    c   (cond ((endp yy) (go bx)))
        (or (member (car yy) (car l) :test elt=)
            (return nil))
        (pop yy)
        (go c)
    bx  (pop l)
        (go a)))

;; helper lset*
(defun x-xor-y (elt= x y)
  (append (x-y elt= x y) (x-y elt= y x)))

(DEFUN X-Y (ELT= X Y)
  (PROG (L R)
        (SETQ L X)
    L	(COND ((ENDP L) (RETURN (NREVERSE R))))
	(OR (MEMBER (CAR L) Y :TEST ELT=)
	    (PUSH (CAR L) R))
	(POP L)
	(GO L)))

(defun x*y (elt= x y)
  (prog (l r)
        (setq l x)
    l	(cond ((endp l) (return (nreverse r))))
	(and (member (car l) y :test elt=)
	     (push (car l) r))
	(pop l)
	(go l)))

(defun x+y (elt= x y)
  (prog (l r)
        (setq l x)
    l	(cond ((endp l) (return (nreverse r))))
	(or (member (car l) y :test elt=)
	     (push (car l) r))
	(pop l)
	(go l)))

;; lset-adjoin
(defun lset-adjoin (elt= list &rest elts)
  (if (functionp elt=)
      (reduce #'(lambda (retlst elt) (adjoin elt retlst :test elt=))
	      elts
	      :initial-value list)
      (error "bad type of argument for =")))

;; lset-union
(defun lset-union (elt= &rest lists)
  (prog (result)
    L   (cond ((null lists) (return result)))
	(setq result (apply #'lset-adjoin elt= (pop lists) result))
	(go L)))

;; lset-union!

;; lset-intersection
(defun lset-intersection (elt= &rest lists)
  (prog (l r)
        (setq l (cdr lists))
	(setq r (car lists))
    l	(cond ((endp l) (return r)))
	(setq r (x*y elt= r (car l)))
	(pop l)
	(go l)))

;; lset-intersection!

;; lset-difference            
(defun lset-difference (elt= &REST LISTS)
  (PROG (L R)
        (SETQ L (CDR LISTS))
	(SETQ R (CAR LISTS))
    L	(COND ((ENDP L) (RETURN R)))
	(SETQ R (X-Y ELT= R (CAR L)))
	(POP L)
	(GO L)))

;; lset-difference!

;; lset-xor
(defun lset-xor (elt= &rest lists)
  (prog (l r)
        (setq l (cdr lists))
	(setq r (car lists))
    l	(cond ((endp l) (return r)))
	(setq r (x-xor-y elt= r (car l)))
	(pop l)
	(go l)))

;; lset-xor!
;; lset-diff+intersection
;; lset-diff+intersection!

;; =============================================================================
;; 基本的な副作用
;; =============================================================================
;;     set-car! set-cdr!

